home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / forth / amiga / amigaker.arc / 03.math < prev    next >
Text File  |  1987-12-30  |  26KB  |  717 lines
  1. ;
  2. ;  03.arithmatic
  3. ;
  4. ;  32 and double (64) bit arithmatics. The double arithmatic is ment to
  5. ;  be used as an internal to retain greater precision.
  6. ;
  7. ;  comparisons to zero and comparisons between two numbers.
  8. ;
  9. ;  double stack operations
  10.  
  11. mulusub           moveq    #0,d4             ;add d0 * 2^16 to
  12.                   moveq    #0,d5             ;  double d2 d3 (d3=high)
  13.                   move.w   d0,d4
  14.                   swap     d4                ;first shift d0 16 times
  15.                   swap     d0                ;then add to double in d2/3
  16.                   move.w   d0,d5
  17.                   add.l    d4,d2
  18.                   addx.l   d5,d3
  19.                   rts
  20.  
  21. * um*             (s n1 n2 -- d )  return double result of n1 times n2
  22.                   dc.w     -1
  23.                   dc.l     link1
  24. link1             set      *-4
  25.                   dc.b     $83,'um',$80!'*'
  26.                   cnop     0,2
  27. _um_times         dc.l     *+4
  28.                   movem.l  (sp),d0-d1        ;if both are word sized
  29.                   moveq    #0,d2             ; use hardware multiply
  30.                   move.w   #$FFFF,d2
  31.                   cmp.l    d2,d0             ;if d0>ffff jump to long 
  32.                   bhi.s    1$                ;  routine
  33.                   cmp.l    d2,d1             ;or  if  d1 > ffff
  34.                   bhi.s    1$
  35.                   mulu     d0,d1             ;hardware multiply
  36.                   moveq    #0,d0
  37.                   movem.l  d0-d1,(sp)
  38.                   jmp      (a3)
  39.                                              ; a.b X c.d =     bxd
  40. 1$                moveq    #0,d2             ;               cxb
  41.                   moveq    #0,d3             ;               axd
  42.                   move.w   2(sp),d0          ;             axc
  43.                   move.w   6(sp),d1          ;             -------
  44.                   mulu     d1,d0             ;             d3 | d2
  45.                   move.l   d0,d2
  46.                   move.w   2(sp),d0          ; long way to multiply two
  47.                   move.w   4(sp),d1          ; 32bit numbers.
  48.                   mulu     d1,d0
  49.                   bsr      mulusub
  50.                   move.w   (sp),d0
  51.                   move.w   6(sp),d1
  52.                   mulu     d1,d0
  53.                   bsr      mulusub
  54.                   move.w   (sp),d0
  55.                   move.w   4(sp),d1
  56.                   mulu     d1,d0
  57.                   add.l    d0,d3
  58.                   move.l   d2,4(sp)
  59.                   move.l   d3,(sp)
  60.                   jmp      (a3)
  61.  
  62. * u*d
  63.                   dc.w     -1
  64.                   dc.l     link1
  65. link1             set      *-4
  66.                   dc.b     $83,'u*',$80!'d'
  67.                   cnop     0,2
  68. _u_times_d        dc.l     nest,_um_times,_exit
  69.  
  70. * um/mod          (s d n -- remainder d#quotient ) double divided by single
  71.                   dc.w     -1
  72.                   dc.l     link1             ; tries to be efficient
  73. link1             set      *-4
  74.                   dc.b     $86,'um/mo',$80!'d'
  75.                   cnop     0,2
  76. _um_divide_mod    dc.l     *+4
  77.                   move.l   (sp)+,d0          ;d0 = b
  78.                   move.l   (sp)+,d3          ;d3 = a(h)
  79.                   move.l   (sp)+,d2          ;d2 = a(l)
  80.                   moveq    #0,d1
  81.                   move.w   #$FFFF,d1         ;d1 holds mask for word test
  82.                   tst.l    d0
  83.                   bne.s    1$                ; if b=0 return an error
  84.                   move.l   d0,-(sp)
  85.                   dc.w     $4878,$FFFF       ;pea -1
  86.                   dc.w     $4878,$FFFF       ; return a double
  87.                   jmp      (a3)
  88. 1$
  89.                   tst.l    d3                ;check for a(h)=0
  90.                   bne.s    um_divide_mod     ;  if not do long division
  91.  
  92.                   cmp.l    d1,d0             ;is b a word?
  93.                   bls.s    2$                ;  if so, do hardware div.
  94.                   cmp.l    d0,d2             ;if a(l) >= b
  95.                   bcc.s    um_divide_mod     ;  do long division.
  96.                   move.l   d2,-(sp)          ; return a(l) as remainder
  97.                   pea      0                 ; and zero as result
  98.                   pea      0
  99.                   jmp      (a3)
  100.  
  101. 2$                                           ;here if b=word
  102.                   cmp.l    d1,d2             ;must check a(l) for long/word
  103.                   bls.s    3$                ;if word divide once
  104.  
  105.                   swap     d2                ;move a(l)highword
  106.                   move.w   d2,d3             ; d3 (ah) was 0
  107.                   divu     d0,d3
  108.                   move.w   d3,d1             ;save Q(h),
  109.                   swap     d1                ; set into high bits
  110.                   swap     d2                ; next do a(l)lowword
  111. 3$
  112.                   move.w   d2,d3             ;move lowword
  113.                   divu     d0,d3
  114.                   move.w   d3,d1             ;save Q(l)
  115.                   clr.w    d3                ; zero upper bits of remainder
  116.                   swap     d3
  117.                   move.l   d3,-(sp)          ;push remainder
  118.                   move.l   d1,-(sp)          ;push quotient
  119.                   pea      0                 ; and a double quotient
  120.                   jmp      (a3)
  121.  
  122.  
  123. um_divide_mod     moveq    #0,d6             ;  b -  d1 d0
  124.                   moveq    #0,d7             ;  a -  d3 d2
  125.                   moveq    #0,d1             ;  a'-  d5 d4
  126.                                              ;  Sc     (sp)
  127.                                              ;  result d7 d6
  128.                                              ;  Sa      a0
  129.                   move.w   d6,-(sp)          ;zero Sc
  130.                   move.l   d6,a0             ;  and Sa
  131.                   tst.l    d3                ; its possible for a=neg
  132.                   bmi.s    4$
  133. 1$                addq.w   #1,a0             ;  shift a left until neg.
  134.                   subq.w   #1,(sp)              increment Sa, decr. Sc
  135.                   lsl.l    #1,d2
  136.                   roxl.l   #1,d3
  137.                   bpl.s    1$
  138. 4$                lsr.l    #1,d3             ;adjust so highest bit is 0
  139.                   roxr.l   #1,d2
  140.                   roxr.l   #1,d7             ; ** but save bit in d7
  141.                   subq.w   #1,a0
  142.                   addq.w   #1,(sp)
  143. 2$                move.l   d2,d4             ; Save a  in  a'
  144.                   move.l   d3,d5
  145. 3$                addq     #1,(sp)           ; shift b left until neg.
  146.                   lsl.l    #1,d0             ;   increment Sc
  147.                   roxl.l   #1,d1
  148.                   bpl.s    3$
  149.                   lsr.l    #1,d1             ;adjust so highest bit is 0
  150.                   roxr.l   #1,d0
  151.                   subq.w   #1,(sp)
  152.                   bmi.s    9$                ;   do not divide
  153. 5$                sub.l    d0,d2
  154.                   subx.l   d1,d3             ; a = a - b
  155.                   eori     #%10000,ccr       ; flip x bit
  156.                   bcs.s    6$
  157.                   move.l   d2,d4             ;subtract was ok, a' <- a
  158.                   move.l   d3,d5
  159.                   bra.s    8$
  160. 6$                move.l   d4,d2             ;restore a
  161.                   move.l   d5,d3
  162. 8$                roxl.l   #1,d6             ;shift x into result
  163.                   roxl.l   #1,d7
  164.                   roxl.l   #1,d2             ; a = a * 2 using d7 bits
  165.                   roxl.l   #1,d3
  166.                   addq.w   #1,a0             ; increment Sa
  167.                   subq.w   #1,(sp)           ;decrement Sc
  168.                   bmi.s    7$                ; exit if minus
  169.                   move.l   d2,d4             ; a' = a
  170.                   move.l   d3,d5
  171.                   bra.s    5$
  172. 7$                subq.w   #1,a0             ; adjust Sa
  173. 9$                move.w   a0,d0             ;get Sa
  174.                   bra.s    11$
  175. 10$               lsr.l    #1,d5             ; shift a' right Sa times
  176.                   roxr.l   #1,d4
  177. 11$               dbra     d0,10$
  178.                   tst.w    (sp)+             ;drop Sc
  179.                   move.l   d4,-(sp)          ;push remainder
  180.                   move.l   d6,-(sp)          ;push result low
  181.                   move.l   d7,-(sp)          ;push result high
  182.                   jmp      (a3)
  183.  
  184. * 0<              (s n -- f ) return true if n is negative
  185.                   dc.w     -1
  186.                   dc.l     link0
  187. link0             set      *-4
  188.                   dc.b     $82,'0',$80!'<'
  189.                   cnop     0,2
  190. _0_less           dc.l     *+4
  191.                   tst.l    (sp)
  192.                   bmi.s    yes
  193.                   bra.s    no
  194.  
  195. * 0=              (s n -- f ) return true if tos is 0
  196.                   dc.w     -1
  197.                   dc.l     link0
  198. link0             set      *-4
  199.                   dc.b     $82,'0',$80!'='
  200.                   cnop     0,2
  201. _0_equal          dc.l     *+4
  202.                   tst.l    (sp)
  203.                   beq.s    yes
  204.                   bra.s    no
  205.  
  206. * 0>              (s n -- f ) return true if tos is positive
  207.                   dc.w     -1
  208.                   dc.l     link0
  209. link0             set      *-4
  210.                   dc.b     $82,'0',$80!'>'
  211.                   cnop     0,2
  212. _0_greater        dc.l     *+4
  213.                   tst.l    (sp)
  214.                   bgt.s    yes
  215.                   bra.s    no
  216.  
  217. * 0<>             (s n -- f ) return true if tos is not 0
  218.                   dc.w     -1
  219.                   dc.l     link0
  220. link0             set      *-4
  221.                   dc.b     $83,'0<',$80!'>'
  222.                   cnop     0,2
  223. _0_notequal       dc.l     *+4
  224.                   tst.l    (sp)
  225.                   bne.s    yes
  226.                   bra.s    no
  227.  
  228. yes               move.l   #-1,(sp)          ;label - yes
  229.                   jmp      (a3)
  230. no                clr.l    (sp)              ;label - no
  231.                   jmp      (a3)
  232.  
  233. * <               (s n1 n2 -- f ) true if n1 < n2
  234.                   dc.w     -1
  235.                   dc.l     link0
  236. link0             set      *-4
  237.                   dc.b     $81,$80!'<'
  238.                   cnop     0,2
  239. _less_than        dc.l     *+4
  240.                   move.l   (sp)+,d0
  241.                   cmp.l    (sp),d0
  242.                   bgt.s    yes
  243.                   bra.s    no
  244.  
  245. * =               (s n1 n2 -- f ) true if n1=n2
  246.                   dc.w     -1
  247.                   dc.l     link1
  248. link1             set      *-4
  249.                   dc.b     $81,$80!'='
  250.                   cnop     0,2
  251. _equals           dc.l     *+4
  252.                   move.l   (sp)+,d0
  253.                   cmp.l    (sp),d0
  254.                   beq.s    yes
  255.                   bra.s    no
  256.  
  257. * >               (s n1 n2 -- f ) true if n1>n2
  258.                   dc.w     -1
  259.                   dc.l     link2
  260. link2             set      *-4
  261.                   dc.b     $81,$80!'>'
  262.                   cnop     0,2
  263. _greater_than     dc.l     *+4
  264.                   move.l   (sp)+,d0
  265.                   cmp.l    (sp),d0
  266.                   blt.s    yes
  267.                   bra.s    no
  268.  
  269. * <>              (s n1 n2 -- f ) true if n1<>n2
  270.                   dc.w     -1
  271.                   dc.l     link0
  272. link0             set      *-4
  273.                   dc.b     $82,'<',$80!'>'
  274.                   cnop     0,2
  275. _not_equals       dc.l     *+4
  276.                   move.l   (sp)+,d0
  277.                   cmp.l    (sp),d0
  278.                   bne.s    yes
  279.                   bra.s    no
  280.  
  281. * ?negate         (s n1 n2 -- n1 ) negate n1 if n2 is negative
  282.                   dc.w     -1
  283.                   dc.l     link3
  284. link3             set      *-4
  285.                   dc.b     $87,'?negat',$80!'e'
  286.                   cnop     0,2
  287. _question_negate  dc.l     *+4
  288.                   move.l   (sp)+,d0
  289.                   bpl.s    1$
  290.                   neg.l    (sp)
  291. 1$                jmp      (a3)
  292.  
  293. * u<              (s n1 n2 -- f ) true if unsigned n1<n2
  294.                   dc.w     -1
  295.                   dc.l     link1
  296. link1             set      *-4
  297.                   dc.b     $82,'u',$80!'<'
  298.                   cnop     0,2
  299. _u_less           dc.l     *+4
  300.                   move.l   (sp)+,d0
  301.                   cmp.l    (sp),d0
  302.                   bhi      yes
  303.                   bra      no
  304.  
  305. * u>              (s n1 n2 -- f ) true if unsigned n1>n2
  306.                   dc.w     -1
  307.                   dc.l     link1
  308. link1             set      *-4
  309.                   dc.b     $82,'u',$80!'>'
  310.                   cnop     0,2
  311. _u_greater        dc.l     *+4
  312.                   move.l   (sp)+,d0
  313.                   cmp.l    (sp),d0
  314.                   bcs      yes
  315.                   bra      no
  316.  
  317. * min             (s n1 n2 -- n3 ) return minimun of n1, n2
  318.                   dc.w     -1
  319.                   dc.l     link1
  320. link1             set      *-4
  321.                   dc.b     $83,'mi',$80!'n'
  322.                   cnop     0,2
  323. _min              dc.l     *+4
  324.                   move.l   (sp)+,d0
  325.                   cmp.l    (sp),d0
  326.                   bgt.s    1$
  327.                   move.l   d0,(sp)
  328. 1$                jmp      (a3)
  329.  
  330. * max             (s n1 n2 -- n3 ) return maximum of n1, n2
  331.                   dc.w     -1
  332.                   dc.l     link1
  333. link1             set      *-4
  334.                   dc.b     $83,'ma',$80!'x'
  335.                   cnop     0,2
  336. _max              dc.l     *+4
  337.                   move.l   (sp)+,d0
  338.                   cmp.l    (sp),d0
  339.                   blt.s    1$
  340.                   move.l   d0,(sp)
  341. 1$                jmp      (a3)
  342.  
  343. * between         (s n min max -- f ) true if min <= n <= max
  344.                   dc.w     -1
  345.                   dc.l     link2
  346. link2             set      *-4
  347.                   dc.b     $87,'betwee',$80!'n'
  348.                   cnop     0,2
  349. _between          dc.l     *+4
  350.                   move.l   (sp)+,d0
  351.                   move.l   (sp)+,d1
  352.                   move.l   (sp),d2
  353.                   cmp.l    d2,d1
  354.                   bgt      no
  355.                   cmp.l    d2,d0
  356.                   blt      no
  357.                   bra      yes
  358.  
  359. * within          (s n min max -- f ) true if  min <= n <  max
  360.                   dc.w     -1
  361.                   dc.l     link3
  362. link3             set      *-4
  363.                   dc.b     $86,'withi',$80!'n'
  364.                   cnop     0,2
  365. _within           dc.l     *+4
  366.                   subq.l   #1,(sp)
  367.                   bra      _between+4
  368.  
  369. * 2@              (s addr -- d ) get double from address
  370.                   dc.w     -1
  371.                   dc.l     link2             ; in memory  addr - high
  372. link2             set      *-4               ;            addr+4 low
  373.                   dc.b     $82,'2',$80!'@'   ; on stack   2nd   low
  374.                   cnop     0,2               ;            tos   high   
  375. _2_fetch          dc.l     *+4
  376.                   move.l   (sp),a0
  377.                   move.l   4(a0),(sp)
  378.                   move.l   (a0),-(sp)
  379.                   jmp      (a3)
  380.  
  381. * 2!              (s d addr -- ) store d at address
  382.                   dc.w     -1
  383.                   dc.l     link2
  384. link2             set      *-4
  385.                   dc.b     $82,'2',$80!'!'
  386.                   cnop     0,2
  387. _2_store          dc.l     *+4
  388.                   move.l   (sp)+,a0
  389.                   move.l   (sp)+,(a0)+
  390.                   move.l   (sp)+,(a0)
  391.                   jmp      (a3)
  392.  
  393. * 2drop           (s d -- )  drop double from tos
  394.                   dc.w     -1
  395.                   dc.l     link2
  396. link2             set      *-4
  397.                   dc.b     $85,'2dro',$80!'p'
  398.                   cnop     0,2
  399. _2drop            dc.l     *+4
  400.                   addq.l   #8,sp
  401.                   jmp      (a3)
  402.  
  403. * 2dup            (s d1 -- d1 d1 )  duplicate double
  404.                   dc.w     -1
  405.                   dc.l     link2
  406. link2             set      *-4
  407.                   dc.b     $84,'2du',$80!'p'
  408.                   cnop     0,2
  409. _2dup             dc.l     *+4
  410.                   move.l   4(sp),-(sp)
  411.                   move.l   4(sp),-(sp)
  412.                   jmp      (a3)
  413.  
  414. * 2swap           (s d1 d2 -- d2 d1 ) swap top two doubles on the stack
  415.                   dc.w     -1
  416.                   dc.l     link2
  417. link2             set      *-4
  418.                   dc.b     $85,'2swa',$80!'p'
  419.                   cnop     0,2
  420. _2swap            dc.l     *+4
  421.                   movem.l  (sp)+,d0-d3
  422.                   exg      d0,d2
  423.                   exg      d1,d3
  424.                   movem.l  d0-d3,-(sp)
  425.                   jmp      (a3)
  426.  
  427. * 2over           (s d1 d2 -- d1 d2 d1 ) copy second double
  428.                   dc.w     -1
  429.                   dc.l     link2
  430. link2             set      *-4
  431.                   dc.b     $85,'2ove',$80!'r'
  432.                   cnop     0,2
  433. _2over            dc.l     *+4
  434.                   move.l   12(sp),-(sp)
  435.                   move.l   12(sp),-(sp)
  436.                   jmp      (a3)
  437.  
  438. * 3dup            (s a b c -- a b c a b c ) duplicate 3 top elements
  439.                   dc.w     -1
  440.                   dc.l     link3
  441. link3             set      *-4
  442.                   dc.b     $84,'3du',$80!'p'
  443.                   cnop     0,2
  444. _3dup             dc.l     *+4
  445.                   lea      12(sp),a0
  446.                   move.l   -(a0),-(sp)
  447.                   move.l   -(a0),-(sp)
  448.                   move.l   -(a0),-(sp)
  449.                   jmp      (a3)
  450.  
  451. * w>s             (s w -- n )  extend word to single
  452.                   dc.w     -1
  453.                   dc.l     link3
  454. link3             set      *-4
  455.                   dc.b     $83,'w',$3E,$80!'s'
  456.                   cnop     0,2
  457. _w_to_s           dc.l     *+4
  458.                   move.l   (sp),d0
  459.                   ext.l    d0
  460.                   move.l   d0,(sp)
  461.                   jmp      (a3)
  462.  
  463. * d+              (s d1 d2 -- dsum )  add two double numbers
  464.                   dc.w     -1
  465.                   dc.l     link0
  466. link0             set      *-4
  467.                   dc.b     $82,'d',$80!'+'
  468.                   cnop     0,2
  469. _d_plus           dc.l     *+4
  470.                   move.l   (sp)+,d1
  471.                   move.l   (sp)+,d0
  472.                   move.l   (sp)+,d2
  473.                   add.l    d0,(sp)
  474.                   addx.l   d2,d1
  475.                   move.l   d1,-(sp)
  476.                   jmp      (a3)
  477.  
  478. * dnegate         (s d -- d )  negate double number on the stack
  479.                   dc.w     -1
  480.                   dc.l     link0
  481. link0             set      *-4
  482.                   dc.b     $87,'dnegat',$80!'e'
  483.                   cnop     0,2
  484. _dnegate          dc.l     *+4
  485.                   neg.l    4(sp)
  486.                   negx.l   (sp)
  487.                   jmp      (a3)
  488.  
  489. * s>d             (s n -- d )  extend single to a double
  490.                   dc.w     -1
  491.                   dc.l     link3
  492. link3             set      *-4
  493.                   dc.b     $83,'s',$3e,$80!'d'
  494.                   cnop     0,2
  495. _s_to_d           dc.l     *+4
  496.                   moveq    #0,d0
  497.                   tst.l    (sp)
  498.                   bpl.s    1$
  499.                   subq.l   #1,d0
  500. 1$                move.l   d0,-(sp)
  501.                   jmp      (a3)
  502.  
  503. * dabs            (s d -- |d| )  return absolute double
  504.                   dc.w     -1
  505.                   dc.l     link0
  506. link0             set      *-4
  507.                   dc.b     $84,'dab',$80!'s'
  508.                   cnop     0,2
  509. _dabs             dc.l     *+4
  510.                   tst.l    (sp)
  511.                   bmi      _dnegate+4
  512.                   jmp      (a3)
  513.  
  514. * d2*             (s d -- d*2 ) 64 bit left shift
  515.                   dc.w     -1
  516.                   dc.l     link0
  517. link0             set      *-4
  518.                   dc.b     $83,'d2',$80!'*'
  519.                   cnop     0,2
  520. _d2_times         dc.l     *+4
  521.                   move.l   (sp)+,d1
  522.                   move.l   (sp),d0
  523.                   lsl.l    #1,d0
  524.                   roxl.l   #1,d1
  525.                   move.l   d0,(sp)
  526.                   move.l   d1,-(sp)
  527.                   jmp      (a3)
  528.  
  529. * d2/             (s d -- d/2 )  64 bit arithmatic right shift
  530.                   dc.w     -1
  531.                   dc.l     link0
  532. link0             set      *-4
  533.                   dc.b     $83,'d2',$80!'/'
  534.                   cnop     0,2
  535. _d2_divide        dc.l     *+4
  536.                   move.l   (sp)+,d1
  537.                   move.l   (sp),d0
  538.                   asr.l    #1,d0
  539.                   roxr.l   #1,d1
  540.                   move.l   d0,(sp)
  541.                   move.l   d1,-(sp)
  542.                   jmp      (a3)
  543.  
  544. * d-              (s d1 d2 -- d3 )  subtract d2 from d1
  545.                   dc.w     -1
  546.                   dc.l     link0
  547. link0             set      *-4
  548.                   dc.b     $82,'d',$80!'-'
  549.                   cnop     0,2
  550. _d_minus          dc.l     *+4
  551.                   move.l   (sp)+,d1
  552.                   move.l   (sp)+,d0
  553.                   move.l   (sp)+,d3
  554.                   sub.l    d0,(sp)
  555.                   subx.l   d1,d3
  556.                   move.l   d3,-(sp)
  557.                   jmp      (a3)
  558.  
  559. * ?dnegate        (s d n -- d )  negate double if n is negative
  560.                   dc.w     -1
  561.                   dc.l     link3
  562. link3             set      *-4
  563.                   dc.b     $88,'?dnegat',$80!'e'
  564.                   cnop     0,2
  565. _question_dnegate dc.l     *+4
  566.                   tst.l    (sp)+
  567.                   bmi      _dnegate+4
  568.                   jmp      (a3)
  569.  
  570. * d=              (s d1 d2 -- f )  true if d1=d2
  571.                   dc.w     -1
  572.                   dc.l     link0
  573. link0             set      *-4
  574.                   dc.b     $82,'d',$80!'='
  575.                   cnop     0,2
  576. _d_equals         dc.l     *+4
  577.                   move.l   (sp)+,d0
  578.                   move.l   (sp)+,d2
  579.                   move.l   (sp)+,d1
  580.                   move.l   (sp),d3
  581.                   cmp.l    d0,d1
  582.                   bne      no
  583.                   cmp.l    d2,d3
  584.                   bne      no
  585.                   bra      yes
  586.  
  587. * *d              (s n1 n2 -- d ) multiply two singles to a double
  588.                   dc.w     -1
  589.                   dc.l     link2
  590. link2             set      *-4
  591.                   dc.b     $82,'*',$80!'d'
  592.                   cnop     0,2
  593. _times_d          dc.l     *+4
  594.                   move.l   (sp)+,d0
  595.                   move.l   (sp)+,d1
  596.                   move.l   d0,d2
  597.                   eor.l    d1,d2
  598.                   move.l   d2,-(rp)
  599.                   move.l   d1,-(sp)
  600.                   bpl.s    1$
  601.                   neg.l    (sp)
  602. 1$                move.l   d0,-(sp)
  603.                   bpl.s    2$
  604.                   neg.l    (sp)
  605. 2$                lea      _um_times,w
  606.                   jsr      callword
  607.                   move.l   (rp)+,-(sp)
  608.                   bra      _question_dnegate+4
  609.  
  610.  
  611. * m/mod           (s d n -- rem quot )  floored division.
  612.                   dc.w     -1
  613.                   dc.l     link1
  614. link1             set      *-4
  615.                   dc.b     $85,'m/mo',$80!'d'
  616.                   cnop     0,2
  617. _m_divide_mod     dc.l     *+4
  618.                   move.l   (sp)+,d0     ;  ?dup if ... then ;
  619.                   beq.s    5$
  620.                   move.l   d0,-(rp)     ; dup >r
  621.                   move.l   (sp),d1
  622.                   eor.l    d0,d1        ; 2dup xor >r
  623.                   move.l   d1,-(rp)
  624.                   move.l   d0,-(rp)     ; >r
  625.                   tst.l    (sp)
  626.                   bpl.s    1$           ; dabs
  627.                   neg.l    4(sp)
  628.                   negx.l   (sp)
  629. 1$                move.l   (rp),-(sp)   ; r@
  630.                   bpl.s    2$
  631.                   neg.l    (sp)         ; abs
  632. 2$                lea      _um_divide_mod,w
  633.                   jsr      callword
  634.                   addq.l   #4,sp        ; drop
  635.                   move.l   (rp)+,d0     ; swap r> ?negate swap
  636.                   bpl.s    3$
  637.                   neg.l    4(sp)
  638. 3$                move.l   (rp)+,d0     ; r> 0< if
  639.                   bpl.s    4$
  640.                   neg.l    (sp)
  641.                   tst.l    4(sp)
  642.                   beq.s    4$
  643.                   subq.l   #1,(sp)
  644.                   move.l   (rp),d0
  645.                   sub.l    4(sp),d0
  646.                   move.l   d0,4(sp)
  647. 4$                tst.l    (rp)+
  648. 5$                jmp      (a3)
  649.  
  650. * *               (s n1 n2 -- n3 ) 32 multiplication
  651.                   dc.w     -1
  652.                   dc.l     link2
  653. link2             set      *-4
  654.                   dc.b     $81,$80!'*'
  655.                   cnop     0,2
  656. _times            dc.l     nest
  657.                   dc.l     _um_times,_drop
  658.                   dc.l     _exit
  659.  
  660. * /mod            ( n1 n2 -- rem quot ) 
  661.                   dc.w     -1
  662.                   dc.l     link3
  663. link3             set      *-4
  664.                   dc.b     $84,'/mo',$80!'d'
  665.                   cnop     0,2
  666. _divide_mod       dc.l     *+4
  667.                   moveq    #0,d0
  668.                   move.l   (sp)+,d1
  669.                   tst.l    (sp)
  670.                   bpl.s    1$
  671.                   neg.l    d0
  672. 1$                move.l   d0,-(sp)
  673.                   move.l   d1,-(sp)
  674.                   bra      _m_divide_mod+4
  675.  
  676. * /               (s n1 n2 -- n3 ) return n1/n2
  677.                   dc.w     -1
  678.                   dc.l     link3
  679. link3             set      *-4
  680.                   dc.b     $81,$80!'/'
  681.                   cnop     0,2
  682. _divide           dc.l     nest
  683.                   dc.l     _divide_mod,_nip
  684.                   dc.l     _exit
  685.  
  686. * mod             (s n1 n2 -- mod )  return n1 mod n2
  687.                   dc.w     -1
  688.                   dc.l     link1
  689. link1             set      *-4
  690.                   dc.b     $83,'mo',$80!'d'
  691.                   cnop     0,2
  692. _mod              dc.l     nest
  693.                   dc.l     _divide_mod,_drop
  694.                   dc.l     _exit
  695.  
  696. * */mod           (s n1 n2 -- rem quot )  internally kept to double
  697.                   dc.w     -1
  698.                   dc.l     link2
  699. link2             set      *-4
  700.                   dc.b     $85,'*/mo',$80!'d'
  701.                   cnop     0,2
  702. _times_divide_mod dc.l     nest
  703.                   dc.l     _to_r,_times_d,_r_from,_m_divide_mod
  704.                   dc.l     _exit
  705.  
  706. * */              (s n1 n2 -- quot )
  707.                   dc.w     -1
  708.                   dc.l     link2
  709. link2             set      *-4
  710.                   dc.b     $82,'*',$80!'/'
  711.                   cnop     0,2
  712. _times_divide     dc.l     nest
  713.                   dc.l     _times_divide_mod,_nip
  714.                   dc.l     _exit
  715.  
  716.  
  717.